home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 001-025 / disk_013 / fractalrep1.bas < prev    next >
BASIC Source File  |  1992-05-06  |  6KB  |  138 lines
  1. 10    screen 1,4,0: randomize -1: pena 7
  2. 11    rgb 1,15,15,15
  3. 12    rgb 8,10,8,6
  4. 13    rgb 11,0,10,15
  5. 20    dim d(64,32)
  6. 30    input "Number of levels <1-6> ";le: if le < 1 or le > 6 then 30
  7. 40    ds=2: for n=1 to le:ds=ds+2^(n-1):next n
  8. 50    mx = ds-1: my = mx/2: pii = pi: rh = pii/6: vt = -pii/5
  9. 51    rc = cos(rh): rs = sin(rh)
  10. 52    vc = cos(vt): vs = sin(vt)
  11. 55    sl = 1000
  12. 60    for n=1 to le:L=10000/1.8^n
  13. 70    ?: ? "Working on level ";n
  14. 80    ib=mx/2^n:sk=ib*2
  15. 90    gosub 150: ' *** Assign heights along X in array ***
  16. 100   gosub 220: ' *** Assign heights along Y in array ***
  17. 110   gosub 290: ' *** Assign heights along diag. in array ***
  18. 120   next n
  19. 130   goto 640:  ' *** Draw ***
  20. 140   ' *** Heights along x ***
  21. 150   for ye = 0 to mx - 1 step sk
  22. 160   for xe = ib+ye to mx step sk
  23. 170   ax = xe-ib: ay = ye: gosub 370: d1=d: ax = xe+ib: gosub 370:                 d2 = d
  24. 180   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  25. 190   next xe
  26. 200   next ye: return
  27. 210   ' *** Heights along Y ***
  28. 220   for xe = mx to 1 step -sk
  29. 230   for ye = ib to xe step sk
  30. 240   ax = xe: ay = ye + ib: gosub 370: d1 = d: ay = ye - ib: gosub 370:           d2 = d
  31. 250   d = (d1+d2)/2 + rnd(1) * L/2 - L/4: ax = xe: ay = ye: gosub 420
  32. 260   next ye
  33. 270   next xe: return
  34. 280   ' *** Heights along diag. ***
  35. 290   for xe = 0 to mx - 1 step sk
  36. 300   for ye = ib to mx - xe step sk
  37. 310   ax = xe + ye - ib: ay = ye - ib: gosub 370: d1 = d
  38. 320   ax = xe + ye + ib: ay = ye + ib: gosub 370: d2 = d
  39. 330   ax = xe + ye: ay = ye: d = (d1+d2)/2 + rnd(1) * L/2 - L/4:                  gosub 420
  40. 340   next ye
  41. 350   next xe: return
  42. 360   ' *** Return data from array ***
  43. 370   if ay > my then 390
  44. 380   by = ay: bx = ax: goto 400
  45. 390   by = mx+1-ay: bx = mx-ax
  46. 400   d = d(bx,by): return
  47. 410   ' *** Put data into array ***
  48. 420   if ay > my then 440
  49. 430   by = ay: bx = ax: goto 450
  50. 440   by = mx+1-ay: bx = mx-ax
  51. 450   d(bx,by) = d: return
  52. 460   ' *** Put in sea level here ***
  53. 470   if zz > sl or z2 > sl then pena 2
  54. 471   if (zz > 0 and z2 <= sl) or (z2 > 0 and z2 <= sl) then pena 8
  55. 472   if xo <> -999 then 500
  56. 480   if zz < 0 then gosub 1070: z2 = zz: zz = 0: goto 620
  57. 490   gosub 1090: goto 610
  58. 500   if z2 > 0 and zz > 0 then 610
  59. 510   if z2 < 0 and zz < 0 then z2 = zz: zz = 0: goto 620
  60. 520   w3 = zz/(zz-z2): x3 = (x2-xx) * w3 + xx: y3 = (y2-yy) * w3 + yy:             z3 = 0
  61. 530   zt = zz: yt = yy: xt = xx
  62. 540   if zz > 0 then 590
  63. 550   ' *** Going into water ***
  64. 560   zz = z3: yy = y3: xx = x3: gosub 950
  65. 570   gosub 1070: zz = 0: yy = yt: xx = xt: z2 = zt: goto 620
  66. 580   ' *** Coming up out of water ***
  67. 590   zz = z3: yy= y3: xx= x3: gosub 950
  68. 600   gosub 1090: zz = zt: yy = yt: xx = xt
  69. 610   z2 = zz
  70. 620   x2 = xx: y2 = yy: return
  71. 630   ' **** Display here ****
  72. 640   gosub 1100: ' *** Set up plotting device or screen ***
  73. 650   xs = .04: ys = .04: zs = .04: ' *** scaling factors ***
  74. 660   for ax = 0 to mx: xo = -999: for ay = 0 to ax
  75. 670   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  76. 680   gosub 940: next ay: next ax
  77. 690   for ay = 0 to mx: xo = -999: for ax = ay to mx
  78. 700   gosub 370: zz = d: yy = ay/mx * 10000: xx = ax/mx * 10000 - yy/2
  79. 710   gosub 940: next ax: next ay
  80. 720   for ex = 0 to mx: xo = -999: for ey = 0 to mx-ex
  81. 730   ax = ex + ey: ay = ey: gosub 370: zz = d: yy = ay/mx *10000
  82. 740   xx = ax/mx * 10000 - yy/2: gosub 940: next ey: next ex
  83. 750   goto 1130: ' *** done plotting, goto end loop ***
  84. 760   ' *** Rotate ***
  85. 770   ox = xx
  86. 780   xx = xx * rc - yy * rs
  87. 790   yy = ox * rs + yy * rc
  88. 800   return
  89. 850   ' *** Tilt down ***
  90. 860   ox = xx
  91. 870   xx = vc * xx - vs * zz
  92. 880   zz = vs * ox + vc * zz
  93. 890   return
  94. 930   ' *** Move or plot to (xp,yp)
  95. 940   gosub 470
  96. 950   xx = xx * xs: yy = yy * ys: zz = zz * zs
  97. 960   gosub 770: ' *** Rotate ***
  98. 970   gosub 860: ' *** Tilt up ***
  99. 980   if xo = -999 then pr$ = "M"
  100. 985   if xo <> -999 then pr$ = "D"
  101. 990   xp = int(yy) + cx: yp = int(zz)
  102. 1000  gosub 1030
  103. 1010  return
  104. 1020  ' *** plot line here ***
  105. 1030  xp = xp * 1.3: yp = 33.14 - .623 * yp
  106. 1040  if pr$ = "M" then x8 = xp: y8 = yp: xo = x
  107. 1045  if y8 > 199 or y8 < 0 or yp > 199 or yp < 0 then return
  108. 1050  draw (x8,y8 to xp,yp): x8 = xp: y8 = yp: return
  109. 1060  ' *** switch to sea color ***
  110. 1070  pena 11: return
  111. 1080  ' *** switch to land color ***
  112. 1090  pena 8: return
  113. 1100  ' * * * setup plotting device or screen * * *
  114. 1110  scnclr: pena 1: area (0,0 to 0,200 to 620,200 to 620,0 to 0,0):              return
  115. 1120  ' *** End loop ***
  116. 1130  getkey a$
  117. 1140  end
  118. 60000 '   This program comes from "Creative Computing" July 1985 pp 78-82
  119. 60010 ' by Michiel van de Panne.  He used the method of generating
  120. 60020 ' fractal landscapes from the September 1984 issue of "Scientific
  121. 60030 ' American".  To modify the program you can change the color of
  122. 60040 ' pena in line 1070 and in line 1090.  You can change the
  123. 60050 ' background color by changing pena to a different color in line
  124. 60060 ' 1110.  The program can only handle 6 levels with a dimension of
  125. 60070 ' d(64,32) in line 20 -- if you want to wait for level 7 to be
  126. 60080 ' plotted, change line 20 to dimension d as dim d(128,64) for 
  127. 60090 ' 16384 triangles to generated.
  128. 60100 '   The size of the landscape can be scaled in line 1030.
  129. 60110 ' Line 10 and lines 1030-1040 have the computer dependent code.
  130. 60120 ' To remove the seas from the landscape change line 470 to read
  131. 60130 ' 470 return.   (check the next paragraph about line 470)
  132. 60140 '   Lines 470-471 have been added and the original line 470 is now
  133. 60150 ' line 472.  This will put white into the mountains when sl > 1000
  134. 60160 ' Also the lines 770-800, 860-890 have been changed.  The original
  135. 60170 ' lines 810-840, 900-920 deleted and lines 51-52 have been added.
  136. 60180 ' The new additions are from letters to the editor from the 
  137. 60190 ' Nov. 85 "Creative Computing" p. 6
  138.